home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / f2c / may_5_92.lha / f2c.VMay_5_1992 / libI77 / lread.c < prev    next >
C/C++ Source or Header  |  1992-05-07  |  10KB  |  554 lines
  1. #include "f2c.h"
  2. #include "fio.h"
  3. #include "fmt.h"
  4. #include "lio.h"
  5. #include "ctype.h"
  6. #include "fp.h"
  7.  
  8. extern char *fmtbuf;
  9. extern char *malloc(), *realloc();
  10. int (*lioproc)(), (*l_getc)(), (*l_ungetc)();
  11. int l_eof;
  12.  
  13. #define isblnk(x) (ltab[x+1]&B)
  14. #define issep(x) (ltab[x+1]&SX)
  15. #define isapos(x) (ltab[x+1]&AX)
  16. #define isexp(x) (ltab[x+1]&EX)
  17. #define issign(x) (ltab[x+1]&SG)
  18. #define iswhit(x) (ltab[x+1]&WH)
  19. #define SX 1
  20. #define B 2
  21. #define AX 4
  22. #define EX 8
  23. #define SG 16
  24. #define WH 32
  25. char ltab[128+1] = {    /* offset one for EOF */
  26.     0,
  27.     0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
  28.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  29.     SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
  30.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  31.     0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  32.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  33.     AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  34.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  35. };
  36.  
  37. #ifdef ungetc
  38.  static int
  39. un_getc(x,cf) int x; FILE *cf;
  40. { return ungetc(x,cf); }
  41. #else
  42. #define un_getc ungetc
  43.  extern int ungetc();
  44. #endif
  45.  
  46. t_getc()
  47. {    int ch;
  48.     if(curunit->uend) return(EOF);
  49.     if((ch=getc(cf))!=EOF) return(ch);
  50.     if(feof(cf))
  51.         l_eof = curunit->uend = 1;
  52.     return(EOF);
  53. }
  54. integer e_rsle()
  55. {
  56.     int ch;
  57.     if(curunit->uend) return(0);
  58.     while((ch=t_getc())!='\n' && ch!=EOF);
  59.     return(0);
  60. }
  61.  
  62. flag lquit;
  63. int lcount,ltype,nml_read;
  64. char *lchar;
  65. double lx,ly;
  66. #define ERR(x) if(n=(x)) return(n)
  67. #define GETC(x) (x=(*l_getc)())
  68. #define Ungetc(x,y) (*l_ungetc)(x,y)
  69.  
  70. l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
  71. {
  72. #define Ptr ((flex *)ptr)
  73.     int i,n,ch;
  74.     doublereal *yy;
  75.     real *xx;
  76.     for(i=0;i<*number;i++)
  77.     {
  78.         if(lquit) return(0);
  79.         if(l_eof)
  80.             err(elist->ciend, EOF, "list in")
  81.         if(lcount == 0) {
  82.             ltype = 0;
  83.             for(;;)  {
  84.                 GETC(ch);
  85.                 switch(ch) {
  86.                 case EOF:
  87.                     goto loopend;
  88.                 case ' ':
  89.                 case '\t':
  90.                 case '\n':
  91.                     continue;
  92.                 case '/':
  93.                     lquit = 1;
  94.                     goto loopend;
  95.                 case ',':
  96.                     lcount = 1;
  97.                     goto loopend;
  98.                 default:
  99.                     (void) Ungetc(ch, cf);
  100.                     goto rddata;
  101.                 }
  102.             }
  103.         }
  104.     rddata:
  105.         switch((int)type)
  106.         {
  107.         case TYSHORT:
  108.         case TYLONG:
  109.         case TYREAL:
  110.         case TYDREAL:
  111.             ERR(l_R(0));
  112.             break;
  113.         case TYCOMPLEX:
  114.         case TYDCOMPLEX:
  115.             ERR(l_C());
  116.             break;
  117.         case TYLOGICAL:
  118.             ERR(l_L());
  119.             break;
  120.         case TYCHAR:
  121.             ERR(l_CHAR());
  122.             break;
  123.         }
  124.     while (GETC(ch) == ' ' || ch == '\t');
  125.     if (ch != ',' || lcount > 1)
  126.         Ungetc(ch,cf);
  127.     loopend:
  128.         if(lquit) return(0);
  129.         if(cf) {
  130.             if (feof(cf))
  131.                 err(elist->ciend,(EOF),"list in")
  132.             else if(ferror(cf)) {
  133.                 clearerr(cf);
  134.                 err(elist->cierr,errno,"list in")
  135.                 }
  136.             }
  137.         if(ltype==0) goto bump;
  138.         switch((int)type)
  139.         {
  140.         case TYSHORT:
  141.             Ptr->flshort=lx;
  142.             break;
  143.         case TYLOGICAL:
  144.         case TYLONG:
  145.             Ptr->flint=lx;
  146.             break;
  147.         case TYREAL:
  148.             Ptr->flreal=lx;
  149.             break;
  150.         case TYDREAL:
  151.             Ptr->fldouble=lx;
  152.             break;
  153.         case TYCOMPLEX:
  154.             xx=(real *)ptr;
  155.             *xx++ = lx;
  156.             *xx = ly;
  157.             break;
  158.         case TYDCOMPLEX:
  159.             yy=(doublereal *)ptr;
  160.             *yy++ = lx;
  161.             *yy = ly;
  162.             break;
  163.         case TYCHAR:
  164.             b_char(lchar,ptr,len);
  165.             break;
  166.         }
  167.     bump:
  168.         if(lcount>0) lcount--;
  169.         ptr += len;
  170.         if (nml_read)
  171.             nml_read++;
  172.     }
  173.     return(0);
  174. #undef Ptr
  175. }
  176. l_R(poststar)
  177.  int poststar;
  178. {
  179.     char s[FMAX+EXPMAXDIGS+4];
  180.     register int ch;
  181.     register char *sp, *spe, *sp1;
  182.     long e, exp;
  183.     double atof();
  184.     int havenum, havestar, se;
  185.  
  186.     if (!poststar) {
  187.         if (lcount > 0)
  188.             return(0);
  189.         lcount = 1;
  190.         }
  191.     ltype = 0;
  192.     exp = 0;
  193.     havestar = 0;
  194. retry:
  195.     sp1 = sp = s;
  196.     spe = sp + FMAX;
  197.     havenum = 0;
  198.  
  199.     switch(GETC(ch)) {
  200.         case '-': *sp++ = ch; sp1++; spe++;
  201.         case '+':
  202.             GETC(ch);
  203.         }
  204.     while(ch == '0') {
  205.         ++havenum;
  206.         GETC(ch);
  207.         }
  208.     while(isdigit(ch)) {
  209.         if (sp < spe) *sp++ = ch;
  210.         else ++exp;
  211.         GETC(ch);
  212.         }
  213.     if (ch == '*' && !poststar) {
  214.         if (sp == sp1 || exp || *s == '-') {
  215.             err(elist->cierr,112,"bad repetition count")
  216.             }
  217.         poststar = havestar = 1;
  218.         *sp = 0;
  219.         lcount = atoi(s);
  220.         goto retry;
  221.         }
  222.     if (ch == '.') {
  223.         GETC(ch);
  224.         if (sp == sp1)
  225.             while(ch == '0') {
  226.                 ++havenum;
  227.                 --exp;
  228.                 GETC(ch);
  229.                 }
  230.         while(isdigit(ch)) {
  231.             if (sp < spe)
  232.                 { *sp++ = ch; --exp; }
  233.             GETC(ch);
  234.             }
  235.         }
  236.     se = 0;
  237.     if (issign(ch))
  238.         goto signonly;
  239.     if (isexp(ch)) {
  240.         GETC(ch);
  241.         if (issign(ch)) {
  242. signonly:
  243.             if (ch == '-') se = 1;
  244.             GETC(ch);
  245.             }
  246.         if (!isdigit(ch)) {
  247. bad:
  248.             err(elist->cierr,112,"exponent field")
  249.             }
  250.  
  251.         e = ch - '0';
  252.         while(isdigit(GETC(ch))) {
  253.             e = 10*e + ch - '0';
  254.             if (e > EXPMAX)
  255.                 goto bad;
  256.             }
  257.         if (se)
  258.             exp -= e;
  259.         else
  260.             exp += e;
  261.         }
  262.     (void) Ungetc(ch, cf);
  263.     if (sp > sp1) {
  264.         ++havenum;
  265.         while(*--sp == '0')
  266.             ++exp;
  267.         if (exp)
  268.             sprintf(sp+1, "e%ld", exp);
  269.         else
  270.             sp[1] = 0;
  271.         lx = atof(s);
  272.         }
  273.     else
  274.         lx = 0.;
  275.     if (havenum)
  276.         ltype = TYLONG;
  277.     else
  278.         switch(ch) {
  279.             case ',':
  280.             case '/':
  281.                 break;
  282.             default:
  283.                 if (havestar && ( ch == ' '
  284.                         ||ch == '\t'
  285.                         ||ch == '\n'))
  286.                     break;
  287.                 if (nml_read > 1) {
  288.                     lquit = 2;
  289.                     return 0;
  290.                     }
  291.                 err(elist->cierr,112,"invalid number")
  292.             }
  293.     return 0;
  294.     }
  295.  
  296.  static int
  297. rd_count(ch)
  298.  register int ch;
  299. {
  300.     if (ch < '0' || ch > '9')
  301.         return 1;
  302.     lcount = ch - '0';
  303.     while(GETC(ch) >= '0' && ch <= '9')
  304.         lcount = 10*lcount + ch - '0';
  305.     Ungetc(ch,cf);
  306.     return lcount <= 0;
  307.     }
  308.  
  309. l_C()
  310. {    int ch, nml_save;
  311.     double lz;
  312.     if(lcount>0) return(0);
  313.     ltype=0;
  314.     GETC(ch);
  315.     if(ch!='(')
  316.     {
  317.         if (nml_read > 1 && (ch < '0' || ch > '9')) {
  318.             Ungetc(ch,cf);
  319.             lquit = 2;
  320.             return 0;
  321.             }
  322.         if (rd_count(ch))
  323.             if(!cf || !feof(cf))
  324.                 err(elist->cierr,112,"complex format")
  325.             else
  326.                 err(elist->cierr,(EOF),"lread");
  327.         if(GETC(ch)!='*')
  328.         {
  329.             if(!cf || !feof(cf))
  330.                 err(elist->cierr,112,"no star")
  331.             else
  332.                 err(elist->cierr,(EOF),"lread");
  333.         }
  334.         if(GETC(ch)!='(')
  335.         {    Ungetc(ch,cf);
  336.             return(0);
  337.         }
  338.     }
  339.     else
  340.         lcount = 1;
  341.     while(iswhit(GETC(ch)));
  342.     Ungetc(ch,cf);
  343.     nml_save = nml_read;
  344.     nml_read = 0;
  345.     if (ch = l_R(1))
  346.         return ch;
  347.     if (!ltype)
  348.         err(elist->cierr,112,"no real part");
  349.     lz = lx;
  350.     while(iswhit(GETC(ch)));
  351.     if(ch!=',')
  352.     {    (void) Ungetc(ch,cf);
  353.         err(elist->cierr,112,"no comma");
  354.     }
  355.     while(iswhit(GETC(ch)));
  356.     (void) Ungetc(ch,cf);
  357.     if (ch = l_R(1))
  358.         return ch;
  359.     if (!ltype)
  360.         err(elist->cierr,112,"no imaginary part");
  361.     while(iswhit(GETC(ch)));
  362.     if(ch!=')') err(elist->cierr,112,"no )");
  363.     ly = lx;
  364.     lx = lz;
  365.     nml_read = nml_save;
  366.     return(0);
  367. }
  368. l_L()
  369. {
  370.     int ch;
  371.     if(lcount>0) return(0);
  372.     ltype=0;
  373.     GETC(ch);
  374.     if(isdigit(ch))
  375.     {
  376.         rd_count(ch);
  377.         if(GETC(ch)!='*')
  378.             if(!cf || !feof(cf))
  379.                 err(elist->cierr,112,"no star")
  380.             else
  381.                 err(elist->cierr,(EOF),"lread");
  382.         GETC(ch);
  383.     }
  384.     if(ch == '.') GETC(ch);
  385.     switch(ch)
  386.     {
  387.     case 't':
  388.     case 'T':
  389.         lx=1;
  390.         break;
  391.     case 'f':
  392.     case 'F':
  393.         lx=0;
  394.         break;
  395.     default:
  396.         if(isblnk(ch) || issep(ch) || ch==EOF)
  397.         {    (void) Ungetc(ch,cf);
  398.             return(0);
  399.         }
  400.         else    err(elist->cierr,112,"logical");
  401.     }
  402.     ltype=TYLONG;
  403.     lcount = 1;
  404.     while(!issep(GETC(ch)) && ch!=EOF);
  405.     (void) Ungetc(ch, cf);
  406.     return(0);
  407. }
  408. #define BUFSIZE    128
  409. l_CHAR()
  410. {    int ch,size,i;
  411.     char quote,*p;
  412.     if(lcount>0) return(0);
  413.     ltype=0;
  414.     if(lchar!=NULL) free(lchar);
  415.     size=BUFSIZE;
  416.     p=lchar=malloc((unsigned int)size);
  417.     if(lchar==NULL) err(elist->cierr,113,"no space");
  418.  
  419.     GETC(ch);
  420.     if(isdigit(ch)) {
  421.         /* allow Fortran 8x-style unquoted string...    */
  422.         /* either find a repetition count or the string    */
  423.         lcount = ch - '0';
  424.         *p++ = ch;
  425.         for(i = 1;;) {
  426.             switch(GETC(ch)) {
  427.                 case '*':
  428.                     if (lcount == 0) {
  429.                         lcount = 1;
  430.                         goto noquote;
  431.                         }
  432.                     p = lchar;
  433.                     goto have_lcount;
  434.                 case ',':
  435.                 case ' ':
  436.                 case '\t':
  437.                 case '\n':
  438.                 case '/':
  439.                     Ungetc(ch,cf);
  440.                     /* no break */
  441.                 case EOF:
  442.                     lcount = 1;
  443.                     ltype = TYCHAR;
  444.                     return *p = 0;
  445.                 }
  446.             if (!isdigit(ch)) {
  447.                 lcount = 1;
  448.                 goto noquote;
  449.                 }
  450.             *p++ = ch;
  451.             lcount = 10*lcount + ch - '0';
  452.             if (++i == size) {
  453.                 lchar = realloc(lchar,
  454.                     (unsigned int)(size += BUFSIZE));
  455.                 p = lchar + i;
  456.                 }
  457.             }
  458.         }
  459.     else    (void) Ungetc(ch,cf);
  460.  have_lcount:
  461.     if(GETC(ch)=='\'' || ch=='"') quote=ch;
  462.     else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
  463.     {    (void) Ungetc(ch,cf);
  464.         return(0);
  465.     }
  466.     else {
  467.         /* Fortran 8x-style unquoted string */
  468.         *p++ = ch;
  469.         for(i = 1;;) {
  470.             switch(GETC(ch)) {
  471.                 case ',':
  472.                 case ' ':
  473.                 case '\t':
  474.                 case '\n':
  475.                 case '/':
  476.                     Ungetc(ch,cf);
  477.                     /* no break */
  478.                 case EOF:
  479.                     ltype = TYCHAR;
  480.                     return *p = 0;
  481.                 }
  482.  noquote:
  483.             *p++ = ch;
  484.             if (++i == size) {
  485.                 lchar = realloc(lchar,
  486.                     (unsigned int)(size += BUFSIZE));
  487.                 p = lchar + i;
  488.                 }
  489.             }
  490.         }
  491.     ltype=TYCHAR;
  492.     for(i=0;;)
  493.     {    while(GETC(ch)!=quote && ch!='\n'
  494.             && ch!=EOF && ++i<size) *p++ = ch;
  495.         if(i==size)
  496.         {
  497.         newone:
  498.             lchar= realloc(lchar, (unsigned int)(size += BUFSIZE));
  499.             p=lchar+i-1;
  500.             *p++ = ch;
  501.         }
  502.         else if(ch==EOF) return(EOF);
  503.         else if(ch=='\n')
  504.         {    if(*(p-1) != '\\') continue;
  505.             i--;
  506.             p--;
  507.             if(++i<size) *p++ = ch;
  508.             else goto newone;
  509.         }
  510.         else if(GETC(ch)==quote)
  511.         {    if(++i<size) *p++ = ch;
  512.             else goto newone;
  513.         }
  514.         else
  515.         {    (void) Ungetc(ch,cf);
  516.             *p = 0;
  517.             return(0);
  518.         }
  519.     }
  520. }
  521. integer s_rsle(a) cilist *a;
  522. {
  523.     int n;
  524.  
  525.     if(!init) f_init();
  526.     if(n=c_le(a)) return(n);
  527.     reading=1;
  528.     external=1;
  529.     formatted=1;
  530.     lioproc = l_read;
  531.     lquit = 0;
  532.     lcount = 0;
  533.     l_eof = 0;
  534.     if(curunit->uwrt && nowreading(curunit))
  535.         err(a->cierr,errno,"read start");
  536.     l_getc = t_getc;
  537.     l_ungetc = un_getc;
  538.     return(0);
  539. }
  540. c_le(a) cilist *a;
  541. {
  542.     fmtbuf="list io";
  543.     if(a->ciunit>=MXUNIT || a->ciunit<0)
  544.         err(a->cierr,101,"stler");
  545.     scale=recpos=0;
  546.     elist=a;
  547.     curunit = &units[a->ciunit];
  548.     if(curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
  549.         err(a->cierr,102,"lio");
  550.     cf=curunit->ufd;
  551.     if(!curunit->ufmt) err(a->cierr,103,"lio")
  552.     return(0);
  553. }
  554.